PC Media 2/PC MEDIA CD02.iso/share/prog/tpsorts/tursort.pas

Pascal/Delphi Source File | 1985-10-23 | 23.8 KB | 704 lines

Program Tursort (output);
{*************************************************************************}
{                                                                         }
{ Program: Tursort.Pas                                                    }
{ Programmer: Keith Shafer                                                }
{             San Diego, CA                                               }
{                                                                         }
{ This program contains various sort routines that can be used in         }
{ programs that you write.  These routines were found in the book titled  }
{ Data Structures Using Pascal by Tenenbaum and Augenstein. The           }
{ sample routines listed below sort integers.  They can be modified       }
{ to sort other data.  I encourage users to add routines not listed       }
{ and to modify the sample program at the bottom of the end of the        }
{ listing.  The idea for this program came from one I have seen in the    }
{ public domain dealing with sort algorithms for the 'BASIC' language.    }
{ I hope that in some way these procedures will help you.                 }
{*************************************************************************}

Const Numelts  = 250;    { change these constants for different }
      Abovelts = 251;    { time comparisons.                    }

Type Arraytype = array[1..Numelts] of Integer;
     Aptr      = 1..Numelts;
     Aptr2     = 0..Abovelts;

Var X,Y : Arraytype;
    N   : Aptr;


procedure time;
type
  regpack = record
              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
            end;

var
  recpack:          regpack;             {assign record}
  ch,cl,dh,dl:      integer;

begin
  with recpack do
    ax := $2c00;                             {initialize correct registers}
  intr($21,recpack);                     {call interrupt}
  with recpack do begin
    ch:=Hi(cx);cl:=Lo(cx);
    dh:=Hi(dx);dl:=Lo(dx);
    end;
    write(dh:4,dl:4);
end;


(*************************************************************************)

Procedure Bubble_Sort_V1 (Var X: Arraytype; N: Aptr);

Var Last, Current : Aptr;
    Hold          : Integer;

Begin
    for Last:=N downto 2
    do begin
           for Current:=1 to N-1
           do begin
                  if X[Current] >= X[Current+1]
                     then begin
                              Hold:=X[Current];
                              X[Current]:=X[Current+1];
                              X[Current+1]:=Hold;
                          end;
           end;
    end;
End;

(*************************************************************************)

Procedure Bubble_Sort_V2 (Var X: Arraytype; N: Aptr);

Var Pass, J  : Aptr;
    Intchnge : Boolean;
    Hold     : Integer;

Begin
    Intchnge:=true;
    Pass:=1;
    While (Pass <= N-1) and (Intchnge)
      { outer loop controls the number of passes }
      do begin
             Intchnge:=false;  { initially no interchanges have been made }
                               { in this pass                             }
             for J:=1 to N-Pass
             { inner loop governs each individual pass }
             do if X[J] >= X[J+1] { elements out of order }
                   then begin
                            { an interchange is necessary }
                            Intchnge:=true;
                            Hold:=X[J];
                            X[J]:=X[J+1];
                            X[J+1]:=Hold;
                        end;
             Pass:=Pass+1;
      end;
End;

(*************************************************************************)

Procedure QuickSort_V1 (Var X: Arraytype; N: Aptr);

   Procedure Quick (lb,ub : Aptr2);

   Var J : Aptr;

       Procedure Rearrange (lb,ub: Aptr2; Var J: Aptr);

       Var Up, Down : Aptr;
           A        : Integer;

       Begin
           A:=X[lb];
           J:=lb;
           Up:=ub;
           Down:=lb;
           repeat
               while (up > down) and (X[Up] >= A)
                  do Up:=Up-1;
               J:=Up;
               if Up <> Down
                  then begin
                           X[Down]:=X[Up];
                                 { move up the array }
                           while (Down < Up) and (X[Down] <= A)
                              do Down:=Down+1;
                           J:=Down;
                           if Down <> Up
                              then X[Up]:=X[Down];
                       end;
           until Down = Up;
           X[J]:=A;
       End; { procedure rearrange }

   Begin { procedure quick }
       if lb < ub
          then begin
                   rearrange(lb,ub,j);
                   quick(lb,j-1);
                   quick(j+1,ub);
               end;
   End; { procedure quick }

Begin { procedure quicksort V1 }
    quick(1,N);
End;  { procedure quicksort V1 }

(*************************************************************************)

Procedure QuickSort_V2 (Var X: Arraytype; N: Aptr);

Type Stackitem = record
                   lb : Aptr2;
                   ub : Aptr2;
                 end;
     Stack = record
               top : 0..Numelts;
               item: array[1..Numelts] of Stackitem;
             end;

Var S : Stack;
    Newbnds : Stackitem;
    I, J    : Aptr;

       Procedure Rearrange (lb,ub: Aptr2; Var J: Aptr);

       Var Up, Down : Aptr;
           A        : Integer;

       Begin
           A:=X[lb];
           J:=lb;
           Up:=ub;
           Down:=lb;
           repeat
               while (up > down) and (X[Up] >= A)
                  do Up:=Up-1;
               J:=Up;
               if Up <> Down
                  then begin
                           X[Down]:=X[Up];
                                 { move up the array }
                           while (Down < Up) and (X[Down] <= A)
                              do Down:=Down+1;
                           J:=Down;
                           if Down <> Up
                              then X[Up]:=X[Down];
                       end;
           until Down = Up;
           X[J]:=A;
       End; { procedure rearrange }

       Procedure Push (Var S: Stack; X: Stackitem);

       Begin
           S.top:=S.top+1;
           S.item[S.top]:=X;
       End; { procedure push }

       Function Empty (S: Stack): Boolean;

       Begin
           if S.top = 0
              then empty:=true
              else empty:=false;
       End; { function empty }

       Procedure Popsub (Var S: Stack; Var X: Stackitem);

       Begin
           if empty(S)
              then writeln ('Error....Stack Underflow')
              else begin
                       X:=S.item[S.top];
                       S.top:=s.top-1;
                   end;
       End; { function popsub }

Begin
    S.top:=0;
    with newbnds
         do begin
                lb:=1;
                ub:=N;
                push(S,newbnds);
                { repeat as long as there are     }
                { unsorted subarrays on the stack }
                while not empty(S)
                      do begin
                             popsub(S,newbnds);
                             while ub > lb
                                   do begin
                                          { process next subarray }
                                          rearrange(lb,ub,j);
                                          { stack the larger subarray }
                                          if j-lb > ub-j
                                          { stack the first subarray }
                                             then begin
                                                      I:=ub;
                                                      ub:=j-1;
                                                      push(S,newbnds);
                                                      { process 2nd subarray }
                                                      lb:=j+1;
                                                      ub:=I;
                                                  end
                                          { stack the second subarray }
                                          else begin
                                                   I:=lb;
                                                   lb:=j+1;
                                                   push(S,newbnds);
                                                   { process 1st subarray }
                                                   lb:=I;
                                                   ub:=j-1;
                                               end;
                                      end;
                         end;
            end;
End; { procedure quicksort V2 }

(*************************************************************************)

Procedure Selection_Sort (Var X: Arraytype; N: Aptr);

Var I, J, Index : Aptr;
    Large       : Integer;

Begin
    for I:=N downto 2
        do begin
               { place the largest number of X[1] through }
               { X[1] into large and its index into index }
               Large:=X[1];
               Index:=1;
               for J:=2 to I
                   do if X[J] > Large
                         then begin
                                  Large:=X[J];
                                  Index:=J;
                              end;
               { place large into position I }
               X[Index]:=X[I];
               X[I]:=Large;
           end;
End; { procedure selection sort }

(*************************************************************************)

Procedure Heap_Sort (Var X: Arraytype; N: Aptr);

{ N must be >= 3 }

Label 10, 11;

Var I, J, K, Y: Integer;

Begin
    { create initial heap }
    for K:=2 to N
        do begin
               { insert X[K] into existing heap of size K-1 }
               I:=K;
               Y:=X[K];
               J:=I div 2;
           while J>0
                do begin
                       if Y <= X[J]
                          then goto 10;
                       X[I]:=X[J];
                       I:=J;
                       J:=I div 2;
                   end;
10:            X[I]:=Y;
           end;
    { We remove X[1] and place it in its proper position }
    { in the array.  We then adjust the heap.            }
    for K:=N downto 2
        do begin
               Y:=X[K];
               X[K]:=X[1];
               { readjust the heap of order k-1           }
               { move y down the heap for proper position }
               I:=1;
               J:=2;
               if (X[3] > X[2]) and (K-1 >= 3)
                  then J:=3;
               { J is the larger son of I }
               { in the heap of size K-1  }
               While J <= K-1
                     do begin
                            if X[J] <= Y
                               then goto 11;
                            X[I]:=X[J];
                            I:=J;
                            J:=2*I;
                            if J+1 <= K-1
                               then if X[J+1] > X[J]
                                       then J:=J+1;
                        end;
11:            X[I]:=Y;
           end;
End; { procedure heap sort }

(*************************************************************************)

Procedure Insert_Sort(Var X: Arraytype; N: Aptr);

Var K: Aptr;
    I: Aptr2;
    Y: Integer;
    Found: Boolean;

Begin
    { Initially X[1] may be thought of as a sorted file }
    { of one element.  After each repetition of the     }
    { following loop, the elements X[1] through X[K] are in order }
    for K:=2 to N
        do begin
               { insert X[K] into the sorted file }
               Y:=X[K];
               { move down one position all numbers }
               { greater than y }
               I:=K-1;
               Found:=false;
               While (I >= 1) and (not found)
                     do if Y < X[I]
                        then begin
                                 X[I+1]:=X[I];
                                 I:=I-1;
                             end
                         else found:=true;
               { insert Y at proper position }
               X[I+1]:=Y;
           end;
End; { procedure insert }

(*************************************************************************)

Procedure Merge_Sort(Var X: Arraytype; N: Aptr);

Var Aux : Arraytype;
    lb2, ub1, ub2 : Aptr;
    lb1, I, J, K  : Aptr2;
    Size : Integer;

Begin
    Size:=1; { merge files of size 1 }
    while Size < N
          do begin
                 lb1:=1; { initialize lower bound of first file }
                 K:=1;   { K is index for auxiliary array       }
                 while lb1+Size <= N
                       { check if there are two files to merge }
                       do begin
                              { compute remaining indices }
                              lb2:=lb1+Size;
                              ub1:=lb2-1;
                              if lb2+Size-1 > N
                                 then ub2:=N
                                 else ub2:=lb2+Size-1;
                              { proceed through the two subfiles }
                              I:=lb1;
                              J:=lb2;
                              while (I <= ub1) and (J <= ub2)
                                    do begin
                                           { enter smaller into the array aux }
                                           if X[I] <= X[J]
                                              then begin
                                                       Aux[K]:=X[I];
                                                       I:=I+1;
                                                   end
                                              else begin
                                                       Aux[K]:=X[J];
                                                       J:=J+1;
                                                   end;
                                            K:=K+1;
                                       end;
                              { At this point one of the subfiles }
                              { has been exahusted. Insert any    }
                              { remaining portions of the other file }
                              while I <= ub1
                                    do begin
                                           Aux[K]:=X[I];
                                           I:=I+1;
                                           K:=K+1;
                                       end;
                              while J <= ub2
                                    do begin
                                           Aux[K]:=X[J];
                                           J:=J+1;
                                           K:=K+1;
                                       end;
                              { advance lb1 to start of next pair of files }
                              lb1:=ub2+1;
                          end;
                          { copy any remaining single file }
                          I:=lb1;
                          while K <= N
                                do begin
                                       Aux[K]:=X[I];
                                       K:=K+1;
                                       I:=I+1;
                                   end;
                          { adjust x and size }
                          for K:=1 to N
                              do X[K]:=Aux[K];
                          Size:=Size * 2;
             end;
End; { procedure merge sort }

(*************************************************************************)

Procedure Radix_Sort(Var X: Arraytype; N: Aptr);

Const M = 3; { number of digits in numelts }

Type Nodetype = Record
                  Info: Integer;
                  Next: Aptr2;
                End;

Var Node: Array[1..Numelts] of Nodetype;
    Front: Array[0..10] of Aptr2;
    Rear: Array[0..9] of Aptr2;
    P: Aptr;
    First, Q, I, J: Aptr2;
    Y, Expon, K: Integer;

Begin
    { intialize linked list }
    for I:=1 to N-1
        do begin
               Node[I].Info:=X[I];
               Node[I].Next:=I+1;
           end;
    Node[N].Info:=X[N];
    Node[N].Next:=0;
    First:=1; { first is the head of the linked list }
    for K:=1 to M
        { M is the number of digits in the numbers }
        do begin
               for I:=0 to 9
                   do Rear[I]:=0;
               for I:=0 to 10
                   do Front[I]:=0; { initialize queues }
               { process each element on the list }
               while First <> 0
                     do begin
                            P:=First;
                            First:=Node[First].Next;
                            Y:=Node[P].Info;
                            { extract kth digit }
                            Expon:=1;
                            for I:=1 to K-1
                                do Expon:=Expon * 10;
                            J:=(Y div Expon) mod 10;
                            { insert y into queue[j] }
                            Q:=Rear[J];
                            If Q = 0
                               then Front[J]:=P
                            else Node[Q].Next:=P;
                            Rear[J]:=P;
                        end;
               { at this point each record is in }
               { its proper queue based on digit }
               { k. We now form a single list    }
               { from all the queue elements     }
               { Find the first element          }
               J:=0;
               While (J <= 9) and (Front[J]=0)
                     do J:=J+1;
               First:=Front[J];
               { link up remaining queues }
               while J <= 9
                     { check if finished }
                     do begin
                            { find next element }
                            I:=J+1;
                            while (I<=9) and (Front[I]=0)
                                  do I:=I+1;
                            if I <= 9
                               then begin
                                        P:=I;
                                        Node[Rear[J]].Next:=Front[I];
                                    end;
                            J:=I;
                        end;
               Node[Rear[P]].Next:=0;
           end; { for...do begin }
    { copy back to original array }
    for I:=1 to N
        do begin
               X[I]:=Node[First].Info;
               First:=Node[First].Next;
           end;
End; { procedure radix sort }

(*************************************************************************)

Procedure Worst_Case_Array(Var X: Arraytype);

Var I : Integer;

Begin
    for I:=1 to Numelts
        do begin
               X[I]:=numelts-I;
           end;
End; { procedure worst case array }

Procedure Best_Case_Array(Var X: Arraytype);

Var I : Integer;

Begin
    for I:=1 to numelts
        do begin
               X[I]:=I;
           end;
End; { procedure best case array }

Procedure Random_Case_Array(Var X: Arraytype);

Var I : Integer;

Begin
    for I:=1 to numelts
        do begin
               X[I]:=Random(numelts);
           end;
End; { procedure random case array }


Procedure Print_Array(X: Arraytype);

Var I : Integer;

Begin
    for I:=1 to numelts
        do begin
               writeln(X[I]);
               delay(50);
           end;
End; { procedure print array }

Procedure Copy_Array(X: Arraytype; Var Y: Arraytype);

Var I: Integer;

Begin
    for I:=1 to numelts
        do begin
               Y[I]:=X[I];
           end;
End; { procedure copy array }

Procedure Check_Array(Y: Arraytype);

Var I: Integer;
    Result: Boolean;

Begin
    Result:=true;
    for I:=1 to numelts-1
        do begin
               if Y[I] > Y[I+1] then Result:=false;
           end;
    if not Result then writeln ('Sorted incorrectly');
End; { procedure check array }

(***********************************************)

Var I, J : Integer;

Begin
    N:=numelts;
    for I:=1 to 3
        do begin
               Case I of
                    1: Worst_Case_Array(X);
                    2: Best_Case_Array(X);
                    3: Random_Case_Array(X);
               end;
               for J:=1 to 9
                   do begin
                          Copy_Array(X,Y);
                          Case I of
                               1: Write ('Numelts=',numelts,'..Worst Case Array...');
                               2: Write ('Numelts=',numelts,'..Best Case Array....');
                               3: Write ('Numelts=',numelts,'..Random Case Array..');
                          end;
                          Case J of
                               1: Begin
                                      Write ('Bubble Sort V1 Start.');
                                      time;
                                      Bubble_Sort_V1(Y,N);
                                      time;
                                  end;
                               2: Begin
                                      Write ('Bubble Sort V2 Start.');
                                      time;
                                      Bubble_Sort_V2(Y,N);
                                      time;
                                  end;
                               3: Begin
                                      Write ('Quick Sort V1 Start..');
                                      time;
                                      QuickSort_V1(Y,N);
                                      time;
                                  end;
                               4: Begin
                                      Write ('Quick Sort V2 Start..');
                                      time;
                                      QuickSort_V2(Y,N);
                                      time;
                                  end;
                               5: Begin
                                      Write ('Selection Sort Start.');
                                      time;
                                      Selection_Sort(Y,N);
                                      time;
                                  end;
                               6: Begin
                                      Write ('Heap Sort Start......');
                                      time;
                                      Heap_Sort(Y,N);
                                      time;
                                  end;
                               7: Begin
                                      Write ('Insert Sort Start....');
                                      time;
                                      Insert_Sort(Y,N);
                                      time;
                                  end;
                               8: Begin
                                      Write ('Merge Sort Start.....');
                                      time;
                                      Merge_Sort(Y,N);
                                      time;
                                  end;
                               9: Begin
                                      Write ('Radix Sort Start.....');
                                      time;
                                      Radix_Sort(Y,N);
                                      time;
                                  end;
                          end;
                          Check_Array(Y);
                          Writeln;
                      end; { J loop }
               Writeln;
           end; { I loop }
End. { program tursort }